home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_perl.idb / usr / freeware / lib / perl5 / 5.00502 / B / Bblock.pm.z / Bblock.pm
Encoding:
Perl POD Document  |  1998-10-28  |  3.4 KB  |  163 lines
  1. package B::Bblock;
  2. use Exporter ();
  3. @ISA = "Exporter";
  4. @EXPORT_OK = qw(find_leaders);
  5.  
  6. use B qw(peekop walkoptree walkoptree_exec
  7.      main_root main_start svref_2object);
  8. use B::Terse;
  9. use strict;
  10.  
  11. my $bblock;
  12. my @bblock_ends;
  13.  
  14. sub mark_leader {
  15.     my $op = shift;
  16.     if ($$op) {
  17.     $bblock->{$$op} = $op;
  18.     }
  19. }
  20.  
  21. sub find_leaders {
  22.     my ($root, $start) = @_;
  23.     $bblock = {};
  24.     mark_leader($start);
  25.     walkoptree($root, "mark_if_leader");
  26.     return $bblock;
  27. }
  28.  
  29. # Debugging
  30. sub walk_bblocks {
  31.     my ($root, $start) = @_;
  32.     my ($op, $lastop, $leader, $bb);
  33.     $bblock = {};
  34.     mark_leader($start);
  35.     walkoptree($root, "mark_if_leader");
  36.     my @leaders = values %$bblock;
  37.     while ($leader = shift @leaders) {
  38.     $lastop = $leader;
  39.     $op = $leader->next;
  40.     while ($$op && !exists($bblock->{$$op})) {
  41.         $bblock->{$$op} = $leader;
  42.         $lastop = $op;
  43.         $op = $op->next;
  44.     }
  45.     push(@bblock_ends, [$leader, $lastop]);
  46.     }
  47.     foreach $bb (@bblock_ends) {
  48.     ($leader, $lastop) = @$bb;
  49.     printf "%s .. %s\n", peekop($leader), peekop($lastop);
  50.     for ($op = $leader; $$op != $$lastop; $op = $op->next) {
  51.         printf "    %s\n", peekop($op);
  52.     }
  53.     printf "    %s\n", peekop($lastop);
  54.     }
  55.     print "-------\n";
  56.     walkoptree_exec($start, "terse");
  57. }
  58.  
  59. sub walk_bblocks_obj {
  60.     my $cvref = shift;
  61.     my $cv = svref_2object($cvref);
  62.     walk_bblocks($cv->ROOT, $cv->START);
  63. }
  64.  
  65. sub B::OP::mark_if_leader {}
  66.  
  67. sub B::COP::mark_if_leader {
  68.     my $op = shift;
  69.     if ($op->label) {
  70.     mark_leader($op);
  71.     }
  72. }
  73.  
  74. sub B::LOOP::mark_if_leader {
  75.     my $op = shift;
  76.     mark_leader($op->next);
  77.     mark_leader($op->nextop);
  78.     mark_leader($op->redoop);
  79.     mark_leader($op->lastop->next);
  80. }
  81.  
  82. sub B::LOGOP::mark_if_leader {
  83.     my $op = shift;
  84.     my $ppaddr = $op->ppaddr;
  85.     mark_leader($op->next);
  86.     if ($ppaddr eq "pp_entertry") {
  87.     mark_leader($op->other->next);
  88.     } else {
  89.     mark_leader($op->other);
  90.     }
  91. }
  92.  
  93. sub B::CONDOP::mark_if_leader {
  94.     my $op = shift;
  95.     mark_leader($op->next);
  96.     mark_leader($op->true);
  97.     mark_leader($op->false);
  98. }
  99.  
  100. sub B::PMOP::mark_if_leader {
  101.     my $op = shift;
  102.     if ($op->ppaddr ne "pp_pushre") {
  103.     my $replroot = $op->pmreplroot;
  104.     if ($$replroot) {
  105.         mark_leader($replroot);
  106.         mark_leader($op->next);
  107.         mark_leader($op->pmreplstart);
  108.     }
  109.     }
  110. }
  111.  
  112. # PMOP stuff omitted
  113.  
  114. sub compile {
  115.     my @options = @_;
  116.     if (@options) {
  117.     return sub {
  118.         my $objname;
  119.         foreach $objname (@options) {
  120.         $objname = "main::$objname" unless $objname =~ /::/;
  121.         eval "walk_bblocks_obj(\\&$objname)";
  122.         die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
  123.         }
  124.     }
  125.     } else {
  126.     return sub { walk_bblocks(main_root, main_start) };
  127.     }
  128. }
  129.  
  130. # Basic block leaders:
  131. #     Any COP (pp_nextstate) with a non-NULL label
  132. #     [The op after a pp_enter] Omit
  133. #     [The op after a pp_entersub. Don't count this one.]
  134. #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
  135. #     The ops pointed at by op_next and op_other of a LOGOP, except
  136. #     for pp_entertry which has op_next and op_other->op_next
  137. #     The ops pointed at by op_true and op_false of a CONDOP
  138. #     The op pointed at by op_pmreplstart of a PMOP
  139. #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
  140. #     [The op after a pp_return] Omit
  141.  
  142. 1;
  143.  
  144. __END__
  145.  
  146. =head1 NAME
  147.  
  148. B::Bblock - Walk basic blocks
  149.  
  150. =head1 SYNOPSIS
  151.  
  152.     perl -MO=Bblock[,OPTIONS] foo.pl
  153.  
  154. =head1 DESCRIPTION
  155.  
  156. See F<ext/B/README>.
  157.  
  158. =head1 AUTHOR
  159.  
  160. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  161.  
  162. =cut
  163.